home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / mosmllib / Path.mlp < prev    next >
Encoding:
Text File  |  1996-07-03  |  12.8 KB  |  395 lines  |  [TEXT/R*ch]
  1. (* Path 6 -- new basis 1995-04-28, 1995-06-06 *)
  2.  
  3. exception Path
  4.  
  5. (* It would make sense to use substrings for internal versions of
  6.  * fromString and toString, and to allocate new strings only when 
  7.  * externalizing the strings.
  8.  
  9.  * Impossible cases: 
  10.    UNIX: {isAbs = false, vol = _, arcs = "" :: _}
  11.    Mac:  {isAbs = true,  vol = _, arcs = "" :: _}
  12. *)
  13.  
  14. local 
  15.     val op @ = List.@
  16.     infix 9 sub
  17.     val op sub = String.sub
  18.     val substring = String.extract
  19.  
  20. #ifdef unix
  21. val slash = "/"
  22. val volslash = "/"
  23. fun isslash c = c = #"/"
  24. fun validVol s = s = ""
  25.  
  26. fun getVol s = 
  27.     if size s >= 1 andalso isslash (s sub 0) then SOME ""
  28.     else NONE
  29.  
  30. fun splitabsvolrest s =
  31.     if size s >= 1 andalso isslash (s sub 0) then 
  32.         (true, "", substring(s, 1, NONE))
  33.     else 
  34.         (false, "", s);    
  35. #endif
  36.  
  37. #ifdef msdos
  38. val slash = "/"
  39. val volslash = "/"
  40. fun isslash c = c = #"\\" orelse c = #"/"
  41. fun validVol s = 
  42.     size s = 0 
  43.     orelse size s >= 2 andalso Char.isAlpha (s sub 0) andalso s sub 1 = #":";
  44.         
  45. fun getVol s = 
  46.     if size s >= 2 andalso Char.isAlpha (s sub 0) andalso s sub 1 = #":" then
  47.         SOME (substring(s, 0, SOME 2))
  48.     else 
  49.         NONE;
  50.  
  51. fun splitabsvolrest s =
  52.     case getVol s of
  53.         NONE   => if size s >= 1 andalso isslash (s sub 0) then 
  54.                       (true,  "", substring(s, 1, NONE))
  55.                   else
  56.                       (false, "", s)
  57.       | SOME v => if size s >= 3 andalso isslash (s sub 2) then 
  58.                       (true,  v, substring(s, 3, NONE))
  59.                   else
  60.                       (false, v, substring(s, 2, NONE))
  61. #endif
  62.  
  63. #ifdef macintosh
  64.  
  65. (* Modified extensively for Macintosh pathnames - 1995-09-17 e *)
  66.  
  67. (* Mac pathnames differ from UNIX pathnames in many respects.
  68.    It is generally impossible to tell from the Mac pathname itself
  69.    - if the path is relative or absolute
  70.    - if the path refers to a file or directory
  71.  
  72.    Slash is spelled ":"
  73.    The root of the directory tree is referred to as "" and is an absolute
  74.    path; otherwise, any name with no colons is considered a relative path.
  75.    A name staring with a colon is always a relative path.
  76.    A name ending in a colon is always a directory path.
  77.  
  78.    There are no special file names such as "." or ".."
  79.    ":" is the current directory
  80.    "::" is up one from the current directory
  81.    ":::" is up two from the current directory, etc.
  82.    ":a::b" = ":b", "a::b:" = "b:"
  83.  
  84.    It is safer to always include a colon in the pathname if you can.
  85.    For example, instead of "foo" for a directory name
  86.                        use "foo:"  to refer to the absolute path
  87.                        use ":foo:" to refer to the relative path
  88.    even though MacOS would allow all three names for the relative path.
  89.  
  90.   A pathname without colons is consider relative. This is what one usually
  91.   wants (plain file names are looked for in the current directory first).
  92.   This leads to odd behavior; e.g., (isCanonical "a") is false, and 
  93.   (base "a.b") is ":a" -- oh well, it tends to work even if it looks weird.
  94. *)
  95.  
  96. val slash = ":"
  97. val volslash = ""
  98. val relslash = ":"
  99. fun isslash c = c = #":"
  100. fun validVol s = s = ""
  101.  
  102. (* empty name ""  => absolute
  103.    first char ":" => relative
  104.    other char ":" => absolute
  105.    else, I picked => relative
  106. *)
  107. fun splitabsvolrest s =
  108.   let val sz = size s
  109.   in
  110.     if       sz = 0           then (true,  "", s)
  111.     else if isslash (s sub 0) then (false, "", substring(s, 1, NONE))
  112.     else let fun hasslash n =
  113.            if n <= 0 then (false, "", s)
  114.            else if isslash (s sub n)
  115.                 then (true, "", s)
  116.                 else hasslash (n-1)
  117.          in hasslash (sz - 1) end
  118.   end
  119.  
  120. #endif
  121.  
  122. in
  123.  
  124. #ifdef macintosh
  125. val parentArc  = "::" (* not really! *)
  126. val currentArc = ":"  (* not really! *)
  127. #else
  128. val parentArc  = ".."
  129. val currentArc = "."
  130. #endif
  131.  
  132. fun isAbsolute p = #1 (splitabsvolrest p)
  133.  
  134. fun isRelative p = not (isAbsolute p);
  135.  
  136. fun fromString p = 
  137.     case splitabsvolrest p of
  138. #ifdef macintosh
  139.         (true,  v,   "") => {isAbs=true,  vol = v, arcs = []}
  140. #else
  141.         (false, v,   "") => {isAbs=false, vol = v, arcs = []}
  142. #endif
  143.       | (isAbs, v, rest) => {isAbs=isAbs, vol = v, 
  144.                              arcs = String.fields isslash rest};
  145.  
  146. fun isRoot p = 
  147.     case splitabsvolrest p of
  148.         (true, _, "") => true
  149.       | _             => false;
  150.  
  151. fun getVolume p = #2 (splitabsvolrest p);
  152. fun validVolume{isAbs, vol} = validVol vol;
  153.  
  154. fun toString (path as {isAbs, vol, arcs}) =
  155.     let fun h []        res = res 
  156.           | h (a :: ar) res = h ar (a :: slash :: res)
  157.     in  
  158.         if validVolume{isAbs=isAbs, vol=vol} then 
  159.             case (isAbs, arcs) of
  160. #ifdef macintosh
  161.                 (false, []         ) => vol ^ relslash
  162.               | (false, a1 :: arest) => 
  163.                     String.concat (List.rev (h arest [a1, relslash, vol]))
  164. #else
  165.                 (false, []         ) => vol
  166.               | (false, "" :: _    ) => raise Path
  167.               | (false, a1 :: arest) => 
  168.                     String.concat (vol :: List.rev (h arest [a1]))
  169. #endif
  170.               | (true,  []         ) => vol ^ volslash
  171.               | (true, a1 :: arest ) => 
  172.                     String.concat (List.rev (h arest [a1, volslash, vol])) 
  173.         else
  174.             raise Path
  175.     end;
  176.  
  177. #ifdef macintosh
  178. fun concat (p1, p2) =
  179.     let fun stripslash path = 
  180.             let val sz = size path
  181.             in if sz > 0 andalso isslash (path sub (sz - 1)) then
  182.                    substring(path, 0, SOME(sz - 1))
  183.                else path
  184.             end
  185.         val p2' = 
  186.             if size p2 > 0 andalso isslash (p2 sub 0)
  187.             then substring(p2, 1, NONE)
  188.             else p2
  189.     in
  190.         if p2 <> "" andalso isAbsolute p2 then raise Path
  191.         else
  192.             case splitabsvolrest p1 of
  193.                 (false, "",   "") =>     relslash ^ p2'
  194.               | (false, v,  path) => v ^ relslash ^ stripslash path ^ slash ^ p2'
  195.               | (true,  v,  ""  ) => v ^ volslash ^ p2'
  196.               | (true,  v,  path) => v ^ volslash ^ stripslash path ^ slash ^ p2'
  197.     end;
  198. #else
  199. fun concat (p1, p2) =
  200.     let fun stripslash path = 
  201.             if isslash (path sub (size path - 1)) then
  202.                 substring(path, 0, SOME(size path - 1))
  203.             else path
  204.     in
  205.         if isAbsolute p2 then raise Path
  206.         else
  207.             case splitabsvolrest p1 of
  208.                 (false, "",   "") => p2
  209.               | (false, v,  path) => v ^ stripslash path ^ slash ^ p2
  210.               | (true,  v,  ""  ) => v ^ volslash ^ p2
  211.               | (true,  v,  path) => v ^ volslash ^ stripslash path ^ slash ^ p2
  212.     end;
  213. #endif
  214.  
  215. #ifdef macintosh
  216. fun getParent p =
  217.     let open List
  218.         fun getpar xs = 
  219.             rev (case rev xs of
  220.                      []                  => []         
  221.                    | "" :: "" :: revrest => "" :: "" :: "" :: revrest
  222.                    | "" ::  _ :: revrest => "" :: revrest
  223.                    |       "" ::      [] => ["",""]
  224.                    |        _ :: revrest => "" :: revrest)
  225.         val {isAbs, vol, arcs} = fromString p 
  226.     in
  227.         case getpar arcs of 
  228.             []   => 
  229.                 if isAbs then toString {isAbs=true, vol=vol, arcs=[]}
  230.                 else ":"
  231.           | arcs => toString {isAbs=isAbs, vol=vol, arcs=arcs}
  232.     end;
  233. #else
  234. fun getParent p =
  235.     let open List
  236.     val {isAbs, vol, arcs} = fromString p 
  237.     fun getpar xs = 
  238.         rev (case rev xs of
  239.              []              => [parentArc]
  240.            | [""]            => if isAbs then [] else [parentArc]
  241.            | ""   :: revrest => parentArc :: revrest
  242.            | "."  :: revrest => parentArc :: revrest
  243.            | ".." :: revrest => parentArc :: parentArc :: revrest
  244.            | last :: revrest => revrest)
  245.     in
  246.         case getpar arcs of 
  247.             []   => 
  248.                 if isAbs then toString {isAbs=true, vol=vol, arcs=[""]}
  249.                 else currentArc
  250.           | arcs => toString {isAbs=isAbs, vol=vol, arcs=arcs}
  251.     end;
  252. #endif
  253.  
  254. #ifdef macintosh
  255. fun canonize p =
  256.     let val {isAbs, vol, arcs} = fromString p 
  257.         fun lastup []                 = if isAbs then [] else [""]
  258.           | lastup ( "" :: res) = "" :: "" :: res
  259.           | lastup (       res) = "" :: res
  260.         fun backup []                 = if isAbs then [] else [""]
  261.           | backup ( "" :: res) = "" :: "" :: res
  262.           | backup ( _  :: res) = res
  263.         fun reduce arcs = 
  264.             let fun h []           []  = if isAbs then [] else [""]
  265.                   | h []           res =             res
  266.                   | h (""::[])     res =      (lastup res)
  267.                   | h (""::ar)     res = h ar (backup res)
  268.                   | h (a1::ar)     res = h ar (a1 :: res)
  269.             in h arcs [] end
  270.     in
  271.         {isAbs=isAbs, vol=vol, arcs=List.rev (reduce arcs)}
  272.     end;
  273.  
  274. fun mkCanonical p = toString (canonize p);
  275. #else
  276. fun mkCanonical p =
  277.     let val {isAbs, vol, arcs} = fromString p 
  278.         fun backup []          = if isAbs then [] else [parentArc]
  279.           | backup (".."::res) = parentArc :: parentArc :: res
  280.           | backup ( _ :: res) = res
  281.         fun reduce arcs = 
  282.             let fun h []         []  = if isAbs then [""] else [currentArc]
  283.                   | h []         res = res
  284.                   | h (""::ar)   res = h ar res
  285.                   | h ("."::ar)  res = h ar res
  286.                   | h (".."::ar) res = h ar (backup res)
  287.                   | h (a1::ar)   res = h ar (a1 :: res)
  288.             in h arcs [] end
  289.     in
  290.         toString {isAbs=isAbs, vol=vol, arcs=List.rev (reduce arcs)}
  291.     end;
  292. #endif
  293.  
  294. #ifdef macintosh
  295. fun parentize      []  = []
  296.   | parentize (""::[]) = []
  297.   | parentize (_ ::ar) = "" :: parentize ar;
  298.  
  299. fun parentize' ar = "" :: parentize ar;
  300.  
  301. fun mkRelative (p1, p2) =
  302.     case (fromString p1, canonize p2) of
  303.         (_ ,                {isAbs=false,...}) => raise Path
  304.       | ({isAbs=false,...}, _                ) => p1
  305.       | ({vol=vol1, arcs=arcs1,...}, {vol=vol2, arcs=arcs2, ...}) =>
  306.             let fun h []      []  = [""]
  307.                   | h a1      []  = a1
  308.                   | h a1 (""::[]) = a1
  309.                   | h (""::[]) a2 = parentize' a2
  310.                   | h      []  a2 = parentize' a2
  311.                   | h (a1 as (a11::a1r)) (a2 as (a21::a2r)) =
  312.                     if a11=a21 then h a1r a2r
  313.                     else parentize a2 @ a1
  314.             in
  315.                 if vol1 <> vol2 then raise Path 
  316.                 else toString {isAbs=false, vol="", arcs=h arcs1 arcs2}
  317.             end;
  318. #else
  319. fun parentize []      = []
  320.   | parentize (_::ar) = parentArc :: parentize ar;
  321.  
  322. fun mkRelative (p1, p2) =
  323.     case (fromString p1, fromString (mkCanonical p2)) of
  324.         (_ ,                {isAbs=false,...}) => raise Path
  325.       | ({isAbs=false,...}, _                ) => p1
  326.       | ({vol=vol1, arcs=arcs1,...}, {vol=vol2, arcs=arcs2, ...}) =>
  327.             let fun h [] [] = ["."]
  328.                   | h a1 [] = a1
  329.                   | h [] a2 = parentize a2
  330.                   | h (a1 as (a11::a1r)) (a2 as (a21::a2r)) =
  331.                     if a11=a21 then h a1r a2r
  332.                     else parentize a2 @ (if arcs1 = [""] then [] else a1)
  333.             in
  334.                 if vol1 <> vol2 then raise Path 
  335.                 else toString {isAbs=false, vol="", arcs=h arcs1 arcs2}
  336.             end;
  337. #endif
  338.  
  339. fun mkAbsolute (p1, p2) =
  340.     if isRelative p2 then raise Path
  341.     else if isAbsolute p1 then p1
  342.     else mkCanonical(concat(p2, p1));
  343.  
  344. fun isCanonical p = mkCanonical p = p;
  345.  
  346. fun joinDirFile {dir, file} = concat(dir, file)
  347.  
  348. fun splitDirFile p =
  349.     let open List
  350.         val {isAbs, vol, arcs} = fromString p 
  351.     in
  352.         case rev arcs of
  353.             []            => 
  354.                 {dir = toString {isAbs=isAbs, vol=vol, arcs=[]}, file = ""  }
  355. #ifdef macintosh
  356.           | "" :: _       => 
  357.                 {dir = toString {isAbs=isAbs, vol=vol, arcs=arcs}, file = ""}
  358.           | arcn :: [] => 
  359.                 {dir = toString {isAbs=isAbs, vol=vol, arcs=[]}, file = arcn}
  360.           | arcn :: farcs => 
  361.                 {dir = toString {isAbs=isAbs, vol=vol, arcs=rev ("" :: farcs)}, 
  362.                  file = arcn}
  363. #else
  364.           | arcn :: farcs => 
  365.                 {dir = toString {isAbs=isAbs, vol=vol, arcs=rev farcs}, 
  366.                  file = arcn}
  367. #endif
  368.     end
  369.  
  370. fun dir s  = #dir (splitDirFile s);
  371. fun file s = #file(splitDirFile s);
  372.  
  373. fun joinBaseExt {base, ext = NONE}    = base
  374.   | joinBaseExt {base, ext = SOME ex} = base ^ "." ^ ex;
  375.  
  376. fun splitBaseExt s =
  377.     let val {dir, file} = splitDirFile s
  378.         open Substring 
  379.         val (fst, snd) = splitr (fn c => c <> #".") (all file)
  380.     in 
  381.         if isEmpty snd         (* dot at right end     *) 
  382.            orelse isEmpty fst  (* no dot               *)
  383.            orelse size fst = 1 (* dot at left end only *) 
  384.             then {base = s, ext = NONE}
  385.         else 
  386.             {base = joinDirFile{dir = dir, 
  387.                                 file = string (trimr 1 fst)},
  388.              ext = SOME (string snd)}
  389.     end;
  390.  
  391. fun ext s  = #ext  (splitBaseExt s);
  392. fun base s = #base (splitBaseExt s);
  393.  
  394. end
  395.